(define-record-type root-window :root-window
  (really-make-root-window width height gcontext win)
  root-window?
  (width root-window-width)
  (height root-window-height)
  (gcontext root-window-gcontext)
  (win root-window-win))

(define (make-root-window display width height)
  (let* ((screen (display:default-screen display))
	 (black (screen:black-pixel screen))
	 (white (screen:white-pixel screen))
	 (win (create-simple-window 
	       display
	       (default-root-window display)
	       0 0
	       width height
	       1 black white))
	 (gc (create-gc
	      display
	      win
	      (make-gc-value-alist
	       (function (gc-function copy))
	       (background black)
	       (foreground white)))))
    (set-gc-font-default! gc)
    (change-window-attributes
     display win 
     (make-set-window-attribute-alist
      (event-mask (event-mask button-press button-release 
			      key-press key-release exposure pointer-motion))))
    (set-wm-protocols! display win
		       (list (intern-atom (current-display)
					  "WM_DELETE_WINDOW" #f)))
    (really-make-root-window width height gc win)))

(define *current-root-window* #f)

(define (root-window) 
  *current-root-window*)

(define *current-display* #f)

(define (current-display)
  *current-display*)

(define (current-screen)
  (display:default-screen (current-display)))

(define *default-font-name* 
  "-*-helvetica-medium-r-normal-*-10-*-*-*-*-*-*-*")

(define *default-font-struct* #f)

(define (default-font-struct)
  *default-font-struct*)

(define (set-gc-font-default! gc)
  (set-gc-font! (current-display) gc 
		(font-struct:fid *default-font-struct*)))
	
(define-record-type bitmap :bitmap
  (really-make-bitmap parent children pixmap gcontext rectangle)
  bitmap?
  (parent bitmap-parent)
  (children bitmap-children set-bitmap-children!)
  (pixmap bitmap-pixmap)
  (gcontext bitmap-gcontext)
  (rectangle bitmap-rectangle set-bitmap-rectangle!))

(define-record-discloser :bitmap
  (lambda (r)
    `(bitmap (rectangle ,(bitmap-rectangle r)))))

(define (bitmap-width bitmap)
  (rectangle-width (bitmap-rectangle bitmap)))

(define (bitmap-height bitmap)
  (rectangle-height (bitmap-rectangle bitmap)))

(define (bitmap-origin bitmap)
  (rectangle-origin (bitmap-rectangle bitmap)))

(define (bitmap-x bitmap)
  (rectangle-x (bitmap-rectangle bitmap)))

(define (bitmap-y bitmap)
  (rectangle-y (bitmap-rectangle bitmap)))

(define (write-bitmap bitmap)
  (write (list (bitmap-x bitmap) (bitmap-x bitmap)
	       (bitmap-width bitmap) (bitmap-height bitmap))))

(define (make-bitmap parent rectangle)
  (let* ((width (rectangle-width rectangle))
	 (height (rectangle-height rectangle))
	 (depth (screen:root-depth (current-screen)))
	 (pm (create-pixmap (current-display) 
			    (root-window-win (root-window))
			    width height depth))
	 (cm (screen:default-colormap (current-screen)))
	 (gcontext (create-gc 
		    (current-display)
		    pm 
		    (make-gc-value-alist
		     (function (gc-function copy))
		     (background (black-pixel (current-display)))
		     (foreground (white-pixel (current-display))))))
	 (bitmap
	  (really-make-bitmap parent '() pm gcontext rectangle)))
    (set-gc-font-default! gcontext)
    (if parent
	(set-bitmap-children! parent
			      (cons bitmap
				    (bitmap-children parent))))
    (bitmap-clear bitmap)
    bitmap))

(define *display-lock* (make-lock))

(define (bitmap-to-front! bitmap)
  (with-lock *display-lock*
    (lambda ()
      (let* ((parent (bitmap-parent bitmap))
	     (siblings (bitmap-children parent)))
	(set-bitmap-children! parent
			      (cons bitmap
				    (delq bitmap siblings)))
	(redraw-bitmap-parent bitmap)))))

(define (bitmap-to-back! bitmap)
  (with-lock *display-lock*
    (lambda ()
      (let* ((parent (bitmap-parent bitmap))
	     (siblings (bitmap-children parent)))
	(set-bitmap-children! parent
			      (append (delq bitmap siblings)
				      (list bitmap)))
	(redraw-bitmap-parent bitmap)))))

(define (bitmap-delete! bitmap)
  (with-lock *display-lock*
    (lambda ()
      (bitmap-delete-unsafe! bitmap)
      (redraw-bitmap-parent bitmap))))

(define (bitmap-delete-unsafe! bitmap)
  (for-each (lambda (child)
	      (bitmap-delete-unsafe! child))
	    (bitmap-children bitmap))
  (cond
   ((bitmap-parent bitmap)
    => (lambda (parent)
	 (let ((siblings (bitmap-children parent)))
	   (set-bitmap-children! parent
				 (delq bitmap siblings))))))
  (free-gc (current-display) (bitmap-gcontext bitmap))
  (free-pixmap (current-display) (bitmap-pixmap bitmap)))

(define (bitmap-move! bitmap point)
  (with-lock *display-lock*
    (lambda ()
      (set-bitmap-rectangle! bitmap
			     (rectangle-move (bitmap-rectangle bitmap)
					     point))
      (redraw-bitmap-parent bitmap))))

(define (paint-bitmap bitmap)
  (let ((origin (bitmap-absolute-origin bitmap)))
    (copy-area (current-display)
	       (bitmap-pixmap bitmap)
	       (root-window-win (root-window))
	       (root-window-gcontext (root-window))
	       0 
	       0
	       (bitmap-width bitmap)
	       (bitmap-height bitmap)
	       (point-x origin) 
	       (point-y origin))))

(define (bitmap=? bitmap-1 bitmap-2)
  (eq? bitmap-1 bitmap-2))

(define (bitmap-in-front? bitmap)
  (and (null? (bitmap-children bitmap))
       (let loop ((bitmap bitmap))
	 (cond
	  ((not bitmap) #t)
	  ((bitmap-parent bitmap)
	   => (lambda (parent)
		(let ((siblings (bitmap-children parent)))
		  (and (bitmap=? bitmap (car siblings))
		       (loop parent)))))
	  (else #t)))))

(define (redraw-bitmap-parent bitmap)
  (cond
   ((bitmap-parent bitmap) => redraw-bitmap-unsafe)
   (else (redraw-bitmap-unsafe bitmap))) ; ### shouldn't happen
  (display-flush (current-display)))

(define (redraw-bitmap bitmap)
  (with-lock *display-lock*
    (lambda ()
      (redraw-bitmap-unsafe bitmap)))
  (display-flush (current-display)))

(define (redraw-bitmap-unsafe bitmap)
  (cond
   ((bitmap-parent bitmap)
    => (lambda (parent)
	 (if (bitmap-in-front? bitmap)
	     (draw-bitmap bitmap)
	     (redraw-bitmap-unsafe parent))))
   (else
    (draw-bitmap bitmap))))

(define (bitmap-absolute-origin bitmap)
  (cond
   ((bitmap-parent bitmap)
    => (lambda (parent)
	 (point+ (bitmap-absolute-origin parent)
		 (bitmap-origin bitmap))))
   (else
    (make-point 0 0))))

(define (draw-bitmap bitmap)
  (if bitmap
      (begin
	(paint-bitmap bitmap)
	(for-each (lambda (child)
		    (draw-bitmap child))
		  (reverse (bitmap-children bitmap))))))

(define (set-raster-function! display gc raster-op)
  (set-gc-function! display gc (raster-function raster-op)))

(define (raster-function raster-op)
  (case raster-op
    ((copy) (gc-function copy))
    ((xor) (gc-function xor))
    ((or) (gc-function or))
    ((and) (gc-function and))
    ((clear) (gc-function clear))
    ((set) (gc-function set))
    (else
     (error "unkown raster-op"
	    raster-op))))

(define (bitmap-clear bitmap)
  (let* ((pixmap (bitmap-pixmap bitmap))
	 (gc (bitmap-gcontext bitmap)))
    (set-gc-function! (current-display) gc (gc-function clear))
    (fill-rectangle (current-display)
		    pixmap gc
		    0 0
		    (bitmap-width bitmap)
		    (bitmap-height bitmap))
    (redraw-bitmap bitmap)))

(define (bitmap-draw-line bitmap raster-op p-1 p-2)
  (let ((pixmap (bitmap-pixmap bitmap))
	(gc (bitmap-gcontext bitmap)))
    (set-raster-function! (current-display) gc raster-op)
    (draw-line (current-display)
	       pixmap gc
	       (point-x p-1) (point-y p-1)
	       (point-x p-2) (point-y p-2))
    (redraw-bitmap bitmap)))

(define (bitmap-draw-rectangle bitmap raster-op r)
  (let ((pixmap (bitmap-pixmap bitmap))
	(gc (bitmap-gcontext bitmap)))
    (set-raster-function! (current-display) gc raster-op)
    (draw-rectangle (current-display) 
		    pixmap gc
		    (rectangle-x r) (rectangle-y r)
		    (rectangle-width r) (rectangle-height r))
    (redraw-bitmap bitmap)))

(define (bitmap-text-size bitmap text)
  (let* ((gc (bitmap-gcontext bitmap))
	 (extents (text-extents (default-font-struct) text))
	 (ascent (char-struct:ascent extents))
	 (descent (char-struct:descent extents)))
    (values (char-struct:width extents)
	    (+ ascent descent)
	    ascent)))

(define (bitmap-draw-text bitmap raster-op p text)
  (let ((pixmap (bitmap-pixmap bitmap))
	(gc (bitmap-gcontext bitmap)))
    (set-raster-function! (current-display) gc raster-op)
    (draw-image-string (current-display) pixmap gc 
		       (point-x p) (point-y p) text)
    (redraw-bitmap bitmap)))

(define texture-solid
  (make-array #t 16 16))

(define texture-grey
  (array '(16 16)
	 #t #f #t #f   #t #f #t #f   #t #f #t #f   #t #f #t #f
	 #f #t #f #t   #f #t #f #t   #f #t #f #t   #f #t #f #t
	 #t #f #t #f   #t #f #t #f   #t #f #t #f   #t #f #t #f
	 #f #t #f #t   #f #t #f #t   #f #t #f #t   #f #t #f #t

	 #t #f #t #f   #t #f #t #f   #t #f #t #f   #t #f #t #f
	 #f #t #f #t   #f #t #f #t   #f #t #f #t   #f #t #f #t
	 #t #f #t #f   #t #f #t #f   #t #f #t #f   #t #f #t #f
	 #f #t #f #t   #f #t #f #t   #f #t #f #t   #f #t #f #t

	 #t #f #t #f   #t #f #t #f   #t #f #t #f   #t #f #t #f
	 #f #t #f #t   #f #t #f #t   #f #t #f #t   #f #t #f #t
	 #t #f #t #f   #t #f #t #f   #t #f #t #f   #t #f #t #f
	 #f #t #f #t   #f #t #f #t   #f #t #f #t   #f #t #f #t

	 #t #f #t #f   #t #f #t #f   #t #f #t #f   #t #f #t #f
	 #f #t #f #t   #f #t #f #t   #f #t #f #t   #f #t #f #t
	 #t #f #t #f   #t #f #t #f   #t #f #t #f   #t #f #t #f
	 #f #t #f #t   #f #t #f #t   #f #t #f #t   #f #t #f #t))

(define texture-horizontal-stripes-1
  (array '(16 16)
	 #t #t #t #t   #t #t #t #t   #t #t #t #t   #t #t #t #t
	 #f #f #f #f   #f #f #f #f   #f #f #f #f   #f #f #f #f
	 #t #t #t #t   #t #t #t #t   #t #t #t #t   #t #t #t #t
	 #f #f #f #f   #f #f #f #f   #f #f #f #f   #f #f #f #f

	 #t #t #t #t   #t #t #t #t   #t #t #t #t   #t #t #t #t
	 #f #f #f #f   #f #f #f #f   #f #f #f #f   #f #f #f #f
	 #t #t #t #t   #t #t #t #t   #t #t #t #t   #t #t #t #t
	 #f #f #f #f   #f #f #f #f   #f #f #f #f   #f #f #f #f

	 #t #t #t #t   #t #t #t #t   #t #t #t #t   #t #t #t #t
	 #f #f #f #f   #f #f #f #f   #f #f #f #f   #f #f #f #f
	 #t #t #t #t   #t #t #t #t   #t #t #t #t   #t #t #t #t
	 #f #f #f #f   #f #f #f #f   #f #f #f #f   #f #f #f #f

	 #t #t #t #t   #t #t #t #t   #t #t #t #t   #t #t #t #t
	 #f #f #f #f   #f #f #f #f   #f #f #f #f   #f #f #f #f
	 #t #t #t #t   #t #t #t #t   #t #t #t #t   #t #t #t #t
	 #f #f #f #f   #f #f #f #f   #f #f #f #f   #f #f #f #f))

(define texture-horizontal-stripes-2
  (array '(16 16)
	 #f #f #f #f   #f #f #f #f   #f #f #f #f   #f #f #f #f
	 #f #f #f #f   #f #f #f #f   #f #f #f #f   #f #f #f #f
	 #f #f #f #f   #f #f #f #f   #f #f #f #f   #f #f #f #f
	 #t #t #t #t   #t #t #t #t   #t #t #t #t   #t #t #t #t

	 #f #f #f #f   #f #f #f #f   #f #f #f #f   #f #f #f #f
	 #f #f #f #f   #f #f #f #f   #f #f #f #f   #f #f #f #f
	 #f #f #f #f   #f #f #f #f   #f #f #f #f   #f #f #f #f
	 #t #t #t #t   #t #t #t #t   #t #t #t #t   #t #t #t #t

	 #f #f #f #f   #f #f #f #f   #f #f #f #f   #f #f #f #f
	 #f #f #f #f   #f #f #f #f   #f #f #f #f   #f #f #f #f
	 #f #f #f #f   #f #f #f #f   #f #f #f #f   #f #f #f #f
	 #t #t #t #t   #t #t #t #t   #t #t #t #t   #t #t #t #t

	 #f #f #f #f   #f #f #f #f   #f #f #f #f   #f #f #f #f
	 #f #f #f #f   #f #f #f #f   #f #f #f #f   #f #f #f #f
	 #f #f #f #f   #f #f #f #f   #f #f #f #f   #f #f #f #f
	 #t #t #t #t   #t #t #t #t   #t #t #t #t   #t #t #t #t))

(define texture-vertical-stripes-1
  (array '(16 16)
	 #t #f #t #f   #t #f #t #f   #t #f #t #f   #t #f #t #f
	 #t #f #t #f   #t #f #t #f   #t #f #t #f   #t #f #t #f
	 #t #f #t #f   #t #f #t #f   #t #f #t #f   #t #f #t #f
	 #t #f #t #f   #t #f #t #f   #t #f #t #f   #t #f #t #f

	 #t #f #t #f   #t #f #t #f   #t #f #t #f   #t #f #t #f
	 #t #f #t #f   #t #f #t #f   #t #f #t #f   #t #f #t #f
	 #t #f #t #f   #t #f #t #f   #t #f #t #f   #t #f #t #f
	 #t #f #t #f   #t #f #t #f   #t #f #t #f   #t #f #t #f

	 #t #f #t #f   #t #f #t #f   #t #f #t #f   #t #f #t #f
	 #t #f #t #f   #t #f #t #f   #t #f #t #f   #t #f #t #f
	 #t #f #t #f   #t #f #t #f   #t #f #t #f   #t #f #t #f
	 #t #f #t #f   #t #f #t #f   #t #f #t #f   #t #f #t #f

	 #t #f #t #f   #t #f #t #f   #t #f #t #f   #t #f #t #f
	 #t #f #t #f   #t #f #t #f   #t #f #t #f   #t #f #t #f
	 #t #f #t #f   #t #f #t #f   #t #f #t #f   #t #f #t #f
	 #t #f #t #f   #t #f #t #f   #t #f #t #f   #t #f #t #f))

(define texture-vertical-stripes-2
  (array '(16 16)
	 #f #f #f #t   #f #f #f #t   #f #f #f #t   #f #f #f #t
	 #f #f #f #t   #f #f #f #t   #f #f #f #t   #f #f #f #t
	 #f #f #f #t   #f #f #f #t   #f #f #f #t   #f #f #f #t
	 #f #f #f #t   #f #f #f #t   #f #f #f #t   #f #f #f #t

	 #f #f #f #t   #f #f #f #t   #f #f #f #t   #f #f #f #t
	 #f #f #f #t   #f #f #f #t   #f #f #f #t   #f #f #f #t
	 #f #f #f #t   #f #f #f #t   #f #f #f #t   #f #f #f #t
	 #f #f #f #t   #f #f #f #t   #f #f #f #t   #f #f #f #t

	 #f #f #f #t   #f #f #f #t   #f #f #f #t   #f #f #f #t
	 #f #f #f #t   #f #f #f #t   #f #f #f #t   #f #f #f #t
	 #f #f #f #t   #f #f #f #t   #f #f #f #t   #f #f #f #t
	 #f #f #f #t   #f #f #f #t   #f #f #f #t   #f #f #f #t

	 #f #f #f #t   #f #f #f #t   #f #f #f #t   #f #f #f #t
	 #f #f #f #t   #f #f #f #t   #f #f #f #t   #f #f #f #t
	 #f #f #f #t   #f #f #f #t   #f #f #f #t   #f #f #f #t
	 #f #f #f #t   #f #f #f #t   #f #f #f #t   #f #f #f #t))

(define texture-checker
  (array '(16 16)
	 #t #t #t #t   #f #f #f #f   #t #t #t #t   #f #f #f #f
	 #t #t #t #t   #f #f #f #f   #t #t #t #t   #f #f #f #f
	 #t #t #t #t   #f #f #f #f   #t #t #t #t   #f #f #f #f
	 #t #t #t #t   #f #f #f #f   #t #t #t #t   #f #f #f #f

	 #f #f #f #f   #t #t #t #t   #f #f #f #f   #t #t #t #t
	 #f #f #f #f   #t #t #t #t   #f #f #f #f   #t #t #t #t
	 #f #f #f #f   #t #t #t #t   #f #f #f #f   #t #t #t #t
	 #f #f #f #f   #t #t #t #t   #f #f #f #f   #t #t #t #t

	 #t #t #t #t   #f #f #f #f   #t #t #t #t   #f #f #f #f
	 #t #t #t #t   #f #f #f #f   #t #t #t #t   #f #f #f #f
	 #t #t #t #t   #f #f #f #f   #t #t #t #t   #f #f #f #f
	 #t #t #t #t   #f #f #f #f   #t #t #t #t   #f #f #f #f

	 #f #f #f #f   #t #t #t #t   #f #f #f #f   #t #t #t #t
	 #f #f #f #f   #t #t #t #t   #f #f #f #f   #t #t #t #t
	 #f #f #f #f   #t #t #t #t   #f #f #f #f   #t #t #t #t
	 #f #f #f #f   #t #t #t #t   #f #f #f #f   #t #t #t #t))

(define (texture->stipple texture)
  (let* ((win (root-window-win (root-window)))
	 (cm (screen:default-colormap (current-screen)))
	 (stipple (create-pixmap (current-display) win 16 16 1))
	 (gc (create-gc (current-display) stipple '()))
	 (white (white-pixel (current-display)))
	 (black (black-pixel (current-display))))
    (do ((x 0 (+ x 1)))
	((= 16 x) stipple)
      (do ((y 0 (+ y 1)))
	  ((= 16 y) stipple)
	(if (array-ref texture x y)
	    (set-gc-foreground! (current-display) gc white)
	    (set-gc-foreground! (current-display) gc black))
	(draw-point (current-display) stipple gc x y)))))

(define (bitmap-fill-rectangle bitmap raster-op texture rectangle)
  (let ((pixmap (bitmap-pixmap bitmap))
	(gc (bitmap-gcontext bitmap))
	(array-bounds (lambda (a) 
			(list->vector (array-shape a)))))
    (if (and (array? texture)
	     (vector? (array-bounds texture))
	     (= (vector-length (array-bounds texture)) 2)
	     (= (vector-ref (array-bounds texture) 0) 16)
	     (= (vector-ref (array-bounds texture) 0) 16))
	(begin
	  (set-gc-fill-style! (current-display) gc (fill-style stippled))
	  (set-gc-stipple! (current-display) gc (texture->stipple texture))
	  (set-raster-function! (current-display) gc raster-op)
	  (fill-rectangle (current-display)
			  pixmap gc 
			  (rectangle-x rectangle)
			  (rectangle-y rectangle)
			  (rectangle-width rectangle)
			  (rectangle-height rectangle))
	  (redraw-bitmap bitmap))
	(error "bitmap-fill-rectangle: texture not of type array 16x16"
	       texture))))

(define (bitmap-bitblt dst-bitmap raster-op dst-point src-bitmap src-rectangle)
  (let* ((src-pixmap (bitmap-pixmap src-bitmap))
	 (dst-pixmap (bitmap-pixmap dst-bitmap))
	 (gc (bitmap-gcontext dst-bitmap)))
    (set-raster-function! (current-display) gc raster-op)
    (copy-area (current-display)
	       src-pixmap 
	       dst-pixmap
	       gc
	       (rectangle-x src-rectangle) 
	       (rectangle-y src-rectangle)
	       (rectangle-width src-rectangle)
	       (rectangle-height src-rectangle)
	       (point-x dst-point) 
	       (point-y dst-point))
    (redraw-bitmap dst-bitmap)))

(define debug-msg
  (lambda messages
    (for-each (lambda (msg)
		(display msg (current-error-port)))
	      messages)
    (newline)))

(define-record-type mouse-message :mouse-message
  (make-mouse-message down? position)
  mouse-message?
  (down? mouse-message-down?)
  (position mouse-message-position))

(define (mouse-message-up? message)
  (not (mouse-message-down? message)))

(define (mouse-message-translate point message)
  (make-mouse-message (mouse-message-down? message)
		      (point- (mouse-message-position message)
			      point)))

(define-record-type key-message :key-message
  (make-key-message keycode string down?)
  key-message?
  (keycode key-message-keycode)
  (string key-message-string)
  (down? key-message-down?))

(define WM_DELETE_WINDOW 214)

(define (make-display label width height)
  (set! *current-display* (open-display))
  (set! *default-font-struct* 
	(load-query-font (current-display) *default-font-name*))
  (set! *current-root-window*
	(make-root-window (current-display) width height))
  (set-wm-name! (current-display) (root-window-win (root-window))
		(string-list->property (list label)))
  (map-window (current-display) (root-window-win (root-window)))
  (display-flush (current-display))
  (let ((mouse-channel (make-channel))
	(keyboard-channel (make-channel))
	(root-bitmap (make-bitmap #f (make-rectangle 0 0 width height))))
    
    (spawn
     (lambda ()
       (display-flush (current-display))
       (dynamic-wind
	(lambda () (values))
	(lambda ()
	  (let event-loop ((mouse-down? #f))
	    (let* ((event (wait-event (current-display)))
		   (type (any-event-type event)))
	      (cond 
	       ((eq? (event-type expose) type)
		;; (debug-msg "expose event")
		(with-lock *display-lock*
		  (lambda ()
		    (draw-bitmap root-bitmap)))
		(display-flush (current-display))
		(event-loop mouse-down?))

	       ((eq? (event-type no-expose) type)
		;; (debug-msg "no-expose event")
		(event-loop mouse-down?))

	       ((eq? (event-type motion-notify) type)
		(let ((pos (make-point (motion-event-x event) 
				       (motion-event-y event))))
		  ;; (debug-msg "motion event" (cons (point-x pos) (point-y pos)))
		  (send mouse-channel (make-mouse-message mouse-down? pos))
		  (relinquish-timeslice)
		  (event-loop mouse-down?)))

	       ((eq? (event-type button-press) type)
		(let ((pos (make-point (button-event-x event) 
				       (button-event-y event))))
		  ;; (debug-msg "mouse event")
		  (send mouse-channel (make-mouse-message #t pos))
		  (relinquish-timeslice)
		  (event-loop #t)))
			  
	       ((eq? (event-type button-release) type)
		(let ((pos (make-point (button-event-x event) 
				       (button-event-y event))))
		  ;; (debug-msg "mouse event")
		  (send mouse-channel (make-mouse-message #f pos))
		  (relinquish-timeslice)
		  (event-loop #f)))

	       ((eq? (event-type key-press) type)
		(let ((msg (make-key-message (key-event-keycode event)
                                             (lookup-string event)
					     #t)))
		  ;; (debug-msg "keyboard press event" (lookup-string event))
		  (send keyboard-channel msg)
		  (relinquish-timeslice)
		  (event-loop mouse-down?)))

	       ((eq? (event-type key-release) type)
		(let ((msg (make-key-message (key-event-keycode event)
                                             (lookup-string event)
					     #f)))
		  ;; (debug-msg "keyboard release event" (lookup-string event))
		  (send keyboard-channel msg)
		  (relinquish-timeslice)
		  (event-loop mouse-down?)))
	       
	       ((and (client-message-event? event)
		     (equal? (property:type (client-message-event-property event))
			     (intern-atom (current-display) "WM_PROTOCOLS" #f))
		     (equal? (car (property:data (client-message-event-property event)))
			     (intern-atom (current-display) "WM_DELETE_WINDOW" #f)))
		(values))

	       (else
		(debug-msg "some unknown event: " (any-event-type event))
		(relinquish-timeslice)
		(event-loop mouse-down?))))))
	(lambda ()
	  (sleep 200)
	  (bitmap-delete-unsafe! root-bitmap)
	  (free-gc (current-display) (root-window-gcontext (root-window)))
	  (destroy-window (current-display) (root-window-win (root-window)))
	  (destroy-window (current-display) (screen:root-window (current-screen)))
	  (close-display (current-display))
	  (set! *current-root-window* #f)
	  (set! *current-display* #f)
	  ;; (debug-msg "event loop terminated")
	  ))))
    
    (values root-bitmap
	    mouse-channel
	    keyboard-channel)))
